Celestin Apprentice 5/Apprentice-Release5.iso/Source Code/C/Applications/Moscow ML 1.31/source code/mosml/src/compiler/Back.sml

Text File | 1996-07-03 | 17.2 KB | 525 lines | [TEXT/R*ch]

(*  back.sml : translation of lambda terms to lists of instructions. *)

open List Fnlib Mixture Const Lambda Prim Instruct;

(* "isReturn" determines if we're in tail call position. *)

fun isReturn (Kreturn :: _ )             = true
  | isReturn (Klabel _ :: Kreturn :: _ ) = true
  | isReturn _                           = false
;

(* Label generation *)

val labelCounter = ref 0;

fun resetLabel() =
  labelCounter := 0
;

fun new_label() =
  (incr labelCounter; !labelCounter)
;

(* Add a label to a list of instructions. *)

fun labelCode C =
  case C of
    Kbranch lbl :: _ =>
      (lbl, C)
  | Klabel lbl :: _ =>
      (lbl, C)
  | _ =>
      let val lbl = new_label()
      in (lbl, Klabel lbl :: C) end
;

(* Generate a branch to the given list of instructions. *)

fun makeBranch C =
  case C of
    Kreturn :: _ =>
      (Kreturn, C)
  | Klabel _ :: Kreturn :: _ =>
      (Kreturn, C)
  | (branch as Kbranch _) :: _ =>
      (branch, C)
  | _ =>
      let val lbl = new_label()
      in (Kbranch lbl, Klabel lbl :: C) end
;

(* Discard all instructions up to the next label. *)

fun discardDeadCode C =
  case C of
    [] => []
  | Klabel _ :: _ => C
  | _ :: rest => discardDeadCode rest
;

(* Generate a jump through table, unless unnecessary. *)

exception JumpOut;

fun add_SwitchTable switchtable C =
  let open Array infix 9 sub in
    (for (fn i => if (switchtable sub i) <> (switchtable sub 0) then
                    raise JumpOut
                  else ())
         1 (length switchtable - 1);
     case C of
         Klabel lbl :: C1 =>
           if lbl = (switchtable sub 0) then C
           else
             Kbranch (switchtable sub 0) :: C
       | _ =>
          Kbranch (switchtable sub 0) :: C)
    handle JumpOut =>
      Kswitch switchtable :: C
  end;

(* Compiling N-way integer branches *)

(* Input: a list of (key, action) pairs, where keys are integers. *)
(* Output: a decision tree with the format below *)

datatype DecisionTree =
    DTfail
  | DTinterval of DecisionTree * Decision * DecisionTree

withtype Decision =
{
  low: int,
  act: Lambda Array.array,
  high: int
};

fun arrayOfList xs =
  if null xs then
    Array.array0
  else
    let open Array
        val len = List.length xs
        val a = array(len, hd xs)
        fun init [] k = ()
          | init (x::xs) k =
              (update(a, k, x); init xs (k+1))
    in init xs 0; a end
;

fun compileNBranch int_of_key clauses =
  let open Array infix 9 sub
      val clauses_i =
        map (fn (key, act) => (int_of_key key : int, act)) clauses
      val clauses_s =
        Sort.sort (fn (key1, act1) => fn (key2, act2) => key1 <= key2)
                  clauses_i
      val keyv = arrayOfList (map fst clauses_s)
      val actv = arrayOfList (map snd clauses_s)
      val n    = length keyv
      fun extractAct start stop =
        let val a =
              array((keyv sub stop) - (keyv sub start) + 1, Lstaticfail)
        in
          for (fn i =>
                 update(a, (keyv sub i) - (keyv sub start), actv sub i))
              start stop;
          a
        end
      (* Now we partition the set of keys keyv into maximal
         dense enough segments. A segment is dense enough
         if its span (max point - min point) is less
         than four times its size (number of points). *)
      fun partition start =
        if start >= n then [] else
        let val stop = ref (n-1) in
          while (keyv sub !stop) - (keyv sub start) >= 255 orelse
                (keyv sub !stop) - (keyv sub start) > 4 * (!stop - start)
          do decr stop;
          (* We've found a segment that is dense enough.
             In the worst case, !stop = start and the segment is
             a single point *)
          (* Now build the vector of actions *)
          { low = keyv sub start,
            act = extractAct start (!stop),
            high = keyv sub !stop } :: partition (!stop + 1)
        end
      val part = arrayOfList (partition 0)
      (* We build a balanced binary tree *)
      fun make_tree start stop =
        if start > stop then
          DTfail
        else
          let val middle = (start + stop) div 2 in
            DTinterval(make_tree start (middle-1),
                       part sub middle,
                       make_tree (middle+1) stop)
          end
  in make_tree 0 (length part - 1) end
;

(* To check if a switch construct contains tags that are unknown at
   compile-time (i.e. exception tags). *)

fun switch_contains_exception_tags clauses =
  exists (fn (EXNtag _, _) => true | _ => false) clauses
;

(* Inversion of a boolean test ( < becomes >= and so on) *)

val invertPrimTest = fn
    PTeq => PTnoteq
  | PTnoteq => PTeq
  | PTnoteqimm x => fatalError "invertPrimTest"
  | PTlt => PTge
  | PTle => PTgt
  | PTgt => PTle
  | PTge => PTlt
;

val invertBoolTest = fn
    Peq_test => Pnoteq_test
  | Pnoteq_test => Peq_test
  | Pint_test t => Pint_test(invertPrimTest t)
  | Pfloat_test t => Pfloat_test(invertPrimTest t)
  | Pstring_test t => Pstring_test(invertPrimTest t)
  | Pnoteqtag_test t => fatalError "invertBoolTest"
;

(* Production of an immediate test *)

val testForAtom = fn
    INTscon x => Pint_test(PTnoteqimm x)
  | CHARscon x => Pint_test(PTnoteqimm (Char.ord x))
  | REALscon x => Pfloat_test(PTnoteqimm x)
  | STRINGscon x => Pstring_test(PTnoteqimm x)
;

(* To keep track of function bodies that remain to be compiled. *)

val stillToCompile  = (Stack.new () : (Lambda * int) Stack.t);

(* The translator from lambda terms to lists of instructions.

   staticfail : the label where Lstaticfail must branch.
   lambda : the lambda term to compile.
   C : the continuation, i.e. the code that follows the code for lambda.

   The tests on the continuation detect tail-calls and avoid jumps to jumps,
   or jumps to function returns.

*)

fun compileExp staticfail =
  let
    open Array infix 9 sub

    fun compexp exp C =
      case exp of
        Lvar n =>
            Kaccess n :: C
      | Lconst cst =>
          (case C of
               Kquote _      :: _ => C
             | Kget_global _ :: _ => C
             | Kaccess _     :: _ => C
             | Kpushmark     :: _ => C
             | _ => Kquote cst :: C)
      | Lapply(body, args) =>
          (case C of
             Kreturn :: C' =>
               compExpList args (Kpush :: compexp body (Ktermapply :: C'))
           | Klabel _ :: Kreturn :: _ =>
               compExpList args (Kpush :: compexp body (Ktermapply :: C))
           | _ =>
               Kpushmark ::
               compExpList args (Kpush :: compexp body (Kapply :: C)))
      | Lfn body =>
          if isReturn C then
            Kgrab :: compexp body C
          else
            let val lbl = new_label() in
              Stack.push (body, lbl) stillToCompile;
              Kclosure lbl :: C
            end
      | Llet(args, body) =>
          let val C1 = if isReturn C then C
                       else Kendlet(List.length args) :: C
              fun comp_args [] =
                    compexp body C1
                | comp_args (exp::rest) =
                    compexp exp (Klet :: comp_args rest)
          in comp_args args end
      | Lletrec([Lfn f], body) =>
          let val C1 = if isReturn C then C else Kendlet 1 :: C
              val lbl = new_label()
          in
            Stack.push (f, lbl) stillToCompile;
            Kletrec1 lbl :: compexp body C1
          end
      | Lletrec(args, body) =>
          let val size = List.length args
              val C1 = if isReturn C then C else Kendlet size :: C
              fun comp_args i = fn
                  [] =>
                    compexp body C1
                | exp :: rest =>
                    compexp exp (Kpush :: Kaccess i :: Kprim Pupdate ::
                                comp_args (i-1) rest)
          in
            foldR
              (fn e => fn C => Kprim(Pdummy 2) :: Klet :: C)
              (comp_args (size-1) args) args
          end
      | Lprim(Pget_global uid, []) =>
            Kget_global uid :: C
      | Lprim(Pset_global uid, [exp]) =>
            compexp exp (Kset_global uid :: C)
      | Lprim(Pmakeblock tag, explist) =>
            compExpList explist (Kmakeblock(tag, List.length explist) :: C)
      | Lprim(Pnot, [exp]) =>
          (case C of
               Kbranchif lbl :: C' =>
                 compexp exp (Kbranchifnot lbl :: C')
             | Kbranchifnot lbl :: C' =>
                 compexp exp (Kbranchif lbl :: C')
             | _ =>
                 compexp exp (Kprim Pnot :: C))
      | Lprim(p as Ptest tst, explist) =>
          (case C of
               Kbranchif lbl :: C' =>
                 compExpList explist (Ktest(tst,lbl) :: C')
             | Kbranchifnot lbl :: C' =>
                 compExpList explist (Ktest(invertBoolTest tst,lbl) :: C')
             | _ =>
                 compExpList explist (Kprim p :: C))
      | Lprim(Praise, explist) =>
            compExpList explist (Kprim Praise :: discardDeadCode C)
      | Lprim(p, explist) =>
            compExpList explist (Kprim p :: C)
      | Lstatichandle(body, Lstaticfail) =>
            compexp body C
      | Lstatichandle(body, handler) =>
          let val (branch1, C1) = makeBranch C
              and lbl2 = new_label()
          in
            compileExp lbl2 body
                       (branch1 :: Klabel lbl2 :: compexp handler C1)
          end
      | Lstaticfail =>
          Kbranch staticfail :: discardDeadCode C
      | Lhandle(body, handler) =>
          let val (branch1, C1) = makeBranch C
              val lbl2 = new_label()
              val C2 = if isReturn C1 then C1 else Kendlet 1 :: C1
          in
            Kpushtrap lbl2 ::
              compexp body
                      (Kpoptrap :: branch1 :: Klabel lbl2
                         :: compexp handler C2)
          end
      | Lif(cond, ifso, ifnot) =>
            compTest2 cond ifso ifnot C
      | Lseq(exp1, exp2) =>
            compexp exp1 (compexp exp2 C)
      | Lwhile(cond, body) =>
          let val lbl1 = new_label()
              and lbl2 = new_label()
          in
            Kbranch lbl1 :: Klabel lbl2 :: Kcheck_signals ::
            compexp body (Klabel lbl1 :: compexp cond (
              Kbranchif lbl2 :: Kquote constUnit :: C))
          end
      | Landalso(exp1, exp2) =>
          (case C of
               Kbranch lbl :: _  =>
                 compexp exp1 (Kstrictbranchifnot lbl :: compexp exp2 C)
             | Kbranchifnot lbl :: _ =>
                 compexp exp1 (Kbranchifnot lbl :: compexp exp2 C)
             | Kbranchif lbl :: C' =>
                 let val (lbl1, C1) = labelCode C' in
                   compexp exp1 (Kbranchifnot lbl1 ::
                                 compexp exp2 (Kbranchif lbl :: C1))
                 end
             | Klabel lbl :: _ =>
                 compexp exp1 (Kstrictbranchifnot lbl :: compexp exp2 C)
             | _ =>
                 let val lbl = new_label() in
                   compexp exp1 (Kstrictbranchifnot lbl ::
                                 compexp exp2 (Klabel lbl :: C))
                 end)
      | Lorelse(exp1, exp2) =>
          (case C of
               Kbranch lbl :: _  =>
                 compexp exp1 (Kstrictbranchif lbl :: compexp exp2 C)
             | Kbranchif lbl :: _  =>
                 compexp exp1 (Kbranchif lbl :: compexp exp2 C)
             | Kbranchifnot lbl :: C' =>
                 let val (lbl1, C1) = labelCode C' in
                   compexp exp1 (Kbranchif lbl1 ::
                                 compexp exp2 (Kbranchifnot lbl :: C1))
                 end
             | Klabel lbl :: _ =>
                 compexp exp1 (Kstrictbranchif lbl :: compexp exp2 C)
             | _ =>
                 let val lbl = new_label() in
                   compexp exp1 (Kstrictbranchif lbl ::
                                 compexp exp2 (Klabel lbl :: C))
                 end)

      | Lcase(arg, clauses) =>
          let val C1 =
            if case clauses of
                   (INTscon _, _) :: _ => true
                 | (CHARscon _, _) :: _ => true
                 | _ => false
            then
              compDecision (compileNBranch intOfAtom clauses) C
            else
              compTests
                (map (fn (cst, act) => (testForAtom cst, act)) clauses) C
          in compexp arg C1 end

      | Lswitch(1, arg, [(CONtag(_,_), exp)]) =>
          compexp exp C
          (* We assume the argument to be safe (not producing side-effects
             and always terminating),
             because switches are generated only by the match compiler *)
      | Lswitch(2, arg, [(CONtag(0,_), exp0)]) =>
          compexp arg (Kbranchif staticfail :: compexp exp0 C)
      | Lswitch(2, arg, [(CONtag(1,_), exp1)]) =>
          compexp arg (Kbranchifnot staticfail :: compexp exp1 C)
      | Lswitch(2, arg, [(CONtag(0,_), exp0), (CONtag(1,_), exp1)]) =>
          compTest2 arg exp1 exp0 C
      | Lswitch(2, arg, [(CONtag(1,_), exp1), (CONtag(0,_), exp0)]) =>
          compTest2 arg exp1 exp0 C
      | Lswitch(size, arg, clauses) =>
          let val C1 =
            if switch_contains_exception_tags clauses then
              compTests
                (map (fn (tag,act) => (Pnoteqtag_test tag, act)) clauses) C
            else if List.length clauses >= size - 5 then
              Kprim Ptag_of :: compDirectSwitch size clauses C
            else
              Kprim Ptag_of ::
                compDecision (compileNBranch intOfAbsoluteTag clauses) C
          in compexp arg C1 end
      | Lunspec =>
          C
      | Lshared(exp, lbl_ref) =>
          if !lbl_ref = Nolabel then
            let val lbl = new_label() in
              lbl_ref := lbl;
              Klabel lbl :: compexp exp C
            end
          else
            Kbranch (!lbl_ref) :: discardDeadCode C

    and compExpList [] C = C
      | compExpList [exp] C = compexp exp C
      | compExpList (exp::rest) C =
          compExpList rest (Kpush :: compexp exp C)

    and compTest2 cond ifso ifnot C =
      let val (branch1, C1) = makeBranch C
          and lbl2 = new_label()
      in
        compexp cond (Kbranchifnot lbl2 ::
                     compexp ifso
                     (branch1 :: Klabel lbl2 :: compexp ifnot C1))
      end

    and compTests clauses C =
      let val (branch1, C1) = makeBranch C
          fun comp [] =
                fatalError "compTests"
            | comp [(test,exp)] =
                Ktest(test, staticfail) :: compexp exp C1
            | comp ((test,exp)::rest) =
                let val lbl = new_label() in
                  Ktest(test, lbl) ::
                    compexp exp (branch1 :: Klabel lbl :: comp rest)
                end
      in comp clauses end

    and compSwitch v branch1 C =
        let val switchtable =
              array(length v, staticfail)
            fun comp_cases n =
              if n >= length v then
                C
              else
                let val (lbl, C1) =
                      labelCode (compexp (v sub n)
                                         (branch1 :: comp_cases (n+1)))
                in
                  update(switchtable, n, lbl); C1
                end
        in add_SwitchTable switchtable (discardDeadCode(comp_cases 0)) end

    and compDecision tree C =
      let val (branch1, C1) = makeBranch C
          fun comp_dec DTfail C =
                Kbranch staticfail :: discardDeadCode C
            | comp_dec (DTinterval(left, dec, right)) C =
                let val (lbl_right, Cright) =
                      case right of
                          DTfail => (staticfail, C)
                        | _      => labelCode (comp_dec right C)
                    val (lbl_left, Cleft) =
                      case left of
                          DTfail => (staticfail, Cright)
                        | _ =>      labelCode (comp_dec left Cright)
                    val {low, act, high} = dec
                in
                  Kbranchinterval(low, high, lbl_left, lbl_right) ::
                  (case length act of
                       1 => compexp (act sub 0) (branch1 :: Cleft)
                     | _ => compSwitch act branch1 Cleft)
                end
      in comp_dec tree C1 end

    and compDirectSwitch size clauses C =
      let val (branch1, C1) = makeBranch C
          val switchtable = array(size, staticfail)
          fun comp_case [] =
                fatalError "compSwitch"
            | comp_case [(tag, exp)] =
                let val (lbl, C2) = labelCode (compexp exp C1) in
                  update(switchtable, intOfAbsoluteTag tag, lbl);
                  C2
                end
            | comp_case ((tag, exp) :: rest) =
                let val (lbl, C2) =
                  labelCode (compexp exp (branch1 :: comp_case rest))
                in
                  update(switchtable, intOfAbsoluteTag tag, lbl);
                  C2
                end
      in add_SwitchTable switchtable (discardDeadCode(comp_case clauses)) end

  in compexp end
;

fun compileRest C =
  let val (exp, lbl) = Stack.pop stillToCompile in
    compileRest (Klabel lbl :: compileExp Nolabel exp (Kreturn :: C))
  end
  handle Stack.Empty =>
    C
;

fun compileLambda is_pure exp =
  let val () = Stack.clear stillToCompile
      val () = resetLabel()
      val init_code =
            compileExp Nolabel exp []
      val function_code =
            compileRest []
  in
    { kph_is_pure = is_pure,
      kph_inits   = init_code,
      kph_funcs   = function_code }
  end;